home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / demo / 6809sim / 6809sim.4th next >
Encoding:
Text File  |  1994-06-18  |  37.3 KB  |  1,300 lines
  1. \ 6809 Assembler, Disassembler and software simulator, written in PFE.
  2. \ Author: L.C. Benschop, Eindhoven, The Netherlands.
  3.  
  4. only forth also extensions also  forth definitions
  5.  
  6. marker empty
  7. create 6809mem 65536 chars allot 
  8.  
  9. \ Words to reference 6809 MEMORY The 6809 is a big-endian machine.
  10. \ These can be adapted so that memory-mapped IO is directed to
  11. \ IO-devices or that those devices are emulated.
  12. : VC@ ( addr --- c)
  13.   65535 and 6809mem + c@ ;
  14. : VC! ( c addr ---)
  15.   65535 and 6809mem + c! ;
  16. : V@ ( addr --- n)
  17.   65535 and dup 6809mem + c@ 8 lshift swap 1+ 65535 and 6809mem + c@ or ;
  18. : V! ( n addr ---)
  19.   65535 and >r dup 8 rshift r@ 6809mem + c! r> 1+ 65535 and 6809mem + c! ;
  20.  
  21. : VLOAD ( addr --- |name ) \ Load object code in memory.
  22.    BL WORD COUNT R/O OPEN-FILE ABORT" File not Found"
  23.    >R
  24.    6809MEM OVER + 65536 rot - r@ READ-FILE DROP drop 
  25.    r> CLOSE-file DROP ;
  26. : VSAVE ( addr len --- |name ) \ Save object code to disk.
  27.    BL WORD COUNT W/O CREATE-FILE ABORT" No room on disk!" >R
  28.    swap 6809MEM + swap r@ WRITE-FILE ABORT" No room on disk!"
  29.    r> CLOSE-FILE DROP ;
  30.  
  31. : defer create 0 , does> @ execute ;
  32. : is ' >body ! ;
  33.  
  34. VOCABULARY 6809ASM
  35. 6809ASM ALSO DEFINITIONS
  36.  
  37. ' C, DEFER C, IS C,
  38. ' ,  DEFER ,  IS ,
  39. ' HERE DEFER HERE IS HERE
  40. ' ALLOT DEFER ALLOT IS ALLOT
  41. VARIABLE VDP
  42. : VHERE ( --- addr)
  43.   VDP @ ;
  44. : VALLOT VDP +! ;
  45. : VC, ( c --- )
  46.   VHERE VC! 1 VALLOT ;
  47. : V, ( n ---)
  48.   VHERE V! 2 VALLOT ;
  49. : ORG VDP ! ;
  50.  
  51. : <MARK ( --- addr )
  52.   HERE ;
  53. : <RESOLVE ( addr ---)
  54.   HERE 1+ - C, ;
  55. : >MARK ( --- addr )
  56.   HERE 0 C, ;
  57. : >RESOLVE ( addr --- )
  58.   HERE OVER 1+ - SWAP VC! ;
  59.  
  60. VARIABLE ?PREBYTE VARIABLE PREBYTE \ Byte $10 or $11 before opcode
  61. VARIABLE ?OPCODE  VARIABLE OPCODE  \ Opcode byte
  62. VARIABLE ?POSTBYTE VARIABLE POSTBYTE \ Byte after opcode indicating mode.
  63. VARIABLE ?OPERAND  \ Address or data after instruction.
  64. VARIABLE MODE \ True is direct addressing false is other.
  65. VARIABLE DPAGE \ Direct page address.
  66. : SETDP ( n ---) \ Set direct page.
  67.   256 * DPAGE ! ;
  68. 0 SETDP
  69.  
  70. : NOINSTR \ Reset all the instruction flags so there will be no instruction.
  71.   ?PREBYTE OFF ?OPCODE OFF ?POSTBYTE OFF ?OPERAND OFF MODE OFF ;
  72. : A; \ Assemble current instruction and reset instruction flags.
  73.   MODE @  IF \ direct addresiing?
  74.    DUP DPAGE @ - 255 U> IF \ Is address 16 bits?
  75.     2 ?OPERAND ! \ Indicate 16 bits address.
  76.     OPCODE @ $F0 AND 0= \ Change opcode byte.
  77.      IF $70 OPCODE +!
  78.      ELSE $20 OPCODE +!
  79.      THEN
  80.    ELSE 1 ?OPERAND ! \ Indicate 8 bis address.
  81.    THEN
  82.   THEN
  83.   ?PREBYTE @ IF PREBYTE @ C, THEN
  84.   ?OPCODE @ IF OPCODE @ C, THEN
  85.   ?POSTBYTE @ IF POSTBYTE @ C, THEN
  86.   ?OPERAND @ IF
  87.    CASE ?OPERAND @
  88.     1 OF C, ENDOF            \ 8 bits data/address.
  89.     2 OF , ENDOF             \ 16 bits data/address.
  90.     3 OF HERE 1+ - C, ENDOF  \ 8 bits relative address.
  91.     4 OF HERE 2 + - , ENDOF   \ 16 bits realtive address.
  92.    ENDCASE
  93.   THEN NOINSTR ;
  94.  
  95.  
  96. : LABEL A; HERE CONSTANT ;
  97.  
  98. : flag10 \ Indicate that next instruction has prebyte $10
  99.   ?PREBYTE ON $10 PREBYTE ! ;
  100. : flag11 \ Indicate that next instruction has prebyte $11
  101.   ?PREBYTE ON $11 PREBYTE ! ;
  102.  
  103. : # \ Signal immediate mode.
  104.   MODE OFF $-10 OPCODE +! ;
  105.  
  106. : USE-POSTBYTE \ Signal that postbyte must be used.
  107.   MODE OFF
  108.   ?POSTBYTE ON
  109.   OPCODE @ $F0 AND 0= IF
  110.    $60 OPCODE +!
  111.   ELSE
  112.    OPCODE @ $80 AND IF
  113.     $10 OPCODE +!
  114.    THEN
  115.   THEN ;
  116.  
  117. : [] \ Signal indirect mode.
  118.   MODE @ IF \ Indirect addressing with 16-bits addres, no postbyte made yet.
  119.    USE-POSTBYTE
  120.    $9F POSTBYTE !   \ Make postbyte.
  121.    2 ?OPERAND !     \ Indicate 16-bits address.
  122.   ELSE
  123.    POSTBYTE @ $80 AND 0= IF \ 5-bits address format already assembled?
  124.     POSTBYTE @ $1F AND DUP $10 AND 0<> $E0 AND OR
  125.     1 ?OPERAND !            \ Signal operand.
  126.     POSTBYTE @ $60 AND $98 OR POSTBYTE ! \ Change postbyte.
  127.    ELSE
  128.     POSTBYTE @ $10 OR POSTBYTE ! \ Indicate indirect addressing.
  129.    THEN
  130.   THEN ;
  131.  
  132. : ,R \ Modes with a constant offset from a register.
  133.   CREATE C,
  134.   DOES> USE-POSTBYTE
  135.         C@ POSTBYTE ! \ Make register field in postbyte.
  136.         DUP 0= IF
  137.          $84 POSTBYTE +! DROP \ Zero offset.
  138.          ?OPERAND OFF
  139.         ELSE
  140.          DUP -16 >= OVER 15 <= AND IF \ 5-bit offset.
  141.           $1F AND POSTBYTE +!
  142.           ?OPERAND OFF
  143.          ELSE
  144.           DUP 128 + 256 U< IF \ 8-bit offset.
  145.            $88 POSTBYTE +!
  146.            1 ?OPERAND !
  147.           ELSE
  148.            $89 POSTBYTE +!    \ 16-bit offset.
  149.            2 ?OPERAND !
  150.           THEN
  151.          THEN
  152.         THEN ;
  153. $00 ,R ,X
  154. $20 ,R ,Y
  155. $40 ,R ,U
  156. $60 ,R ,S
  157.  
  158. : AMODE \ addressing modes with no operands.
  159.   CREATE C,
  160.   DOES> USE-POSTBYTE
  161.         C@ POSTBYTE !
  162.         ?OPERAND OFF ;
  163. $80 AMODE ,X+   $81 AMODE ,X++ $82 AMODE ,-X   $83 AMODE ,--X
  164. $85 AMODE B,X   $86 AMODE A,X  $8B AMODE D,X
  165. $A0 AMODE ,Y+   $A1 AMODE ,Y++ $A2 AMODE ,-Y   $A3 AMODE ,--Y
  166. $A5 AMODE B,Y   $A6 AMODE A,Y  $AB AMODE D,Y
  167. $C0 AMODE ,U+   $C1 AMODE ,U++ $C2 AMODE ,-U   $C3 AMODE ,--U
  168. $C5 AMODE B,U   $C6 AMODE A,U  $CB AMODE D,U
  169. $E0 AMODE ,S+   $E1 AMODE ,S++ $E2 AMODE ,-S   $E3 AMODE ,--S
  170. $E5 AMODE B,S   $E6 AMODE A,S  $EB AMODE D,S
  171.  
  172. : ,PCR \ Signal program counter relative.
  173.   USE-POSTBYTE
  174.   DUP
  175.   HERE ?PREBYTE @ - 3 + - \ Subtract address after instruction
  176.   128 + 256 U< IF \ 8-bits offset good?
  177.    3 ?OPERAND !
  178.    $8C POSTBYTE !
  179.   ELSE
  180.    4 ?OPERAND !
  181.    $8D POSTBYTE !
  182.   THEN ;
  183.  
  184. : USE-OPCODE ( c ---)
  185.   ?OPCODE ON
  186.   OPCODE ! ;
  187.  
  188. : IN1 \ Simple instructions with one byte opcode
  189.   CREATE C,
  190.   DOES> >R A; R> C@ USE-OPCODE ;
  191. $12 IN1 NOP    $13 IN1 SYNC
  192. $19 IN1 DAA    $1D IN1 SEX
  193. $39 IN1 RTS    $3A IN1 ABX
  194. $3B IN1 RTI    $3D IN1 MUL
  195. $3F IN1 SWI    : SWI2 SWI flag10 ; : SWI3 SWI flag11 ;
  196. $40 IN1 NEGA   $50 IN1 NEGB
  197. $43 IN1 COMA   $53 IN1 COMB
  198. $44 IN1 LSRA   $54 IN1 LSRB
  199. $46 IN1 RORA   $56 IN1 RORB
  200. $47 IN1 ASRA   $57 IN1 ASRB
  201. $48 IN1 ASLA   $58 IN1 ASLB
  202. $48 IN1 LSLA   $58 IN1 LSLB
  203. $49 IN1 ROLA   $59 IN1 ROLB
  204. $4A IN1 DECA   $5A IN1 DECB
  205. $4C IN1 INCA   $5C IN1 INCB
  206. $4D IN1 TSTA   $5D IN1 TSTB
  207. $4F IN1 CLRA   $5F IN1 CLRB
  208. \ Though not no-operand instructions the LEA instructions
  209. \ are treated correctly as the postbyte is added by the mode words.
  210. $30 IN1 LEAX   $31 IN1 LEAY
  211. $32 IN1 LEAS   $33 IN1 LEAU
  212. : DEX LEAX -1 ,X ; : INX LEAX 1 ,X ;
  213. : DES LEAS -1 ,S ; : INS LEAS 1 ,S ;
  214. : DEY LEAY -1 ,Y ; : INY LEAY 1 ,Y ;
  215.  
  216. : BR-8 \ relative branches with 8-bit offset
  217.   CREATE C,
  218.   DOES> >R A; R> C@ USE-OPCODE 3 ?OPERAND ! ;
  219.   $20 BR-8 BRA   $21 BR-8 BRN
  220.   $22 BR-8 BHI   $23 BR-8 BLS
  221.   $24 BR-8 BCC   $25 BR-8 BCS
  222.   $24 BR-8 BHS   $25 BR-8 BLO
  223.   $26 BR-8 BNE   $27 BR-8 BEQ
  224.   $28 BR-8 BVC   $29 BR-8 BVS
  225.   $2A BR-8 BPL   $2B BR-8 BMI
  226.   $2C BR-8 BGE   $2D BR-8 BLT
  227.   $2E BR-8 BGT   $2F BR-8 BLE
  228.   $8D BR-8 BSR
  229.  
  230. : LBRA
  231.   A; $16 USE-OPCODE 4 ?OPERAND ! ;
  232. : LBSR
  233.   A; $17 USE-OPCODE 4 ?OPERAND ! ;
  234.  
  235. : BR16 \ Relative branches with 16-bit offset.
  236.   CREATE C,
  237.   DOES> >R A; R> C@ USE-OPCODE flag10 4 ?OPERAND ! ;
  238.                   $21 BR16 LBRN
  239.   $22 BR16 LBHI   $23 BR16 LBLS
  240.   $24 BR16 LBCC   $25 BR16 LBCS
  241.   $24 BR16 LBHS   $25 BR16 LBLO
  242.   $26 BR16 LBNE   $27 BR16 LBEQ
  243.   $28 BR16 LBVC   $29 BR16 LBVS
  244.   $2A BR16 LBPL   $2B BR16 LBMI
  245.   $2C BR16 LBGE   $2D BR16 LBLT
  246.   $2E BR16 LBGT   $2F BR16 LBLE
  247.  
  248. : IN2 \ Instructions with one immediate data byte.
  249.   CREATE C,
  250.   DOES> >R A; R> C@ USE-OPCODE 1 ?OPERAND ! ;
  251. $1A IN2 ORCC  $1C IN2 ANDCC  $3C IN2 CWAI
  252. : CLC ANDCC $FE ; : SEC ORCC $01 ;
  253. : CLF ANDCC $BF ; : SEF ORCC $40 ;
  254. : CLI ANDCC $EF ; : SEI ORCC $10 ;
  255. : CLIF ANDCC $AF ; : SEIF ORCC $50 ;
  256. : CLV ANDCC $FD ; : SEV ORCC $02 ;
  257. : % ( --- n) \ Interpret next word as a binary number.
  258.   BASE @ 2 BASE ! BL WORD NUMBER? drop DROP SWAP BASE ! ;
  259.  
  260. : REG \ Registers as used in PUSH PULL TFR and EXG instructions.
  261.   CREATE C, C,
  262.   DOES> ?OPERAND @ IF \ Is a PUSH/PULL instruction meant?
  263.          1+ C@ OR
  264.         ELSE
  265.          C@ POSTBYTE +! \ It's a TFR,EXG instruction.
  266.         THEN ;
  267. $06 $00 REG D,  $06 $00 REG D
  268. $10 $10 REG X,  $10 $01 REG X
  269. $20 $20 REG Y,  $20 $02 REG Y
  270. $40 $30 REG U,  $40 $03 REG U
  271. $40 $40 REG S,  $40 $04 REG S
  272. $80 $50 REG PC, $80 $05 REG PC
  273. $02 $80 REG A,  $02 $08 REG A
  274. $04 $90 REG B,  $04 $09 REG B
  275. $01 $A0 REG CC, $01 $0A REG CC
  276. $08 $B0 REG DP, $08 $0B REG DP
  277.  
  278. : EXG A; $1E USE-OPCODE ?POSTBYTE ON 0 POSTBYTE ! ;
  279. : TFR A; $1F USE-OPCODE ?POSTBYTE ON 0 POSTBYTE ! ;
  280. : STK \ Stack instructions.
  281.   CREATE C,
  282.   DOES> >R A; R> C@ USE-OPCODE
  283.         1 ?OPERAND ! 0 ;
  284. $34 STK PSHS  $35 STK PULS
  285. $36 STK PSHU  $37 STK PULU
  286.  
  287. : OP-8 \ Instructions with 8-bits data.
  288.   CREATE C,
  289.   DOES> >R A; R> C@ USE-OPCODE
  290.         MODE ON
  291.         1 ?OPERAND ! ;
  292. $00 OP-8 NEG  $03 OP-8 COM
  293. $04 OP-8 LSR  $06 OP-8 ROR
  294. $07 OP-8 ASR  $08 OP-8 ASL
  295. $08 OP-8 LSL  $09 OP-8 ROL
  296. $0A OP-8 DEC  $0C OP-8 INC
  297. $0D OP-8 TST  $0E OP-8 JMP
  298. $0F OP-8 CLR
  299. $90 OP-8 SUBA $D0 OP-8 SUBB
  300. $91 OP-8 CMPA $D1 OP-8 CMPB
  301. $92 OP-8 SBCA $D2 OP-8 SBCB
  302. $94 OP-8 ANDA $D4 OP-8 ANDB
  303. $95 OP-8 BITA $D5 OP-8 BITB
  304. $96 OP-8 LDA  $D6 OP-8 LDB
  305. $97 OP-8 STA  $D7 OP-8 STB
  306. $98 OP-8 EORA $D8 OP-8 EORB
  307. $99 OP-8 ADCA $D9 OP-8 ADCB
  308. $9A OP-8 ORA  $DA OP-8 ORB
  309. $9B OP-8 ADDA $DB OP-8 ADDB
  310. $9D OP-8 JSR
  311.  
  312. : OP16 \ Instructions with 16-bits daia.
  313.   CREATE C,
  314.   DOES> >R A; R> C@ USE-OPCODE
  315.         MODE ON
  316.         2 ?OPERAND ! ;
  317. $93 OP16 SUBD  $D3 OP16 ADDD
  318. $9C OP16 CMPX  $DC OP16 LDD  $DD OP16 STD
  319. $9E OP16 LDX   $DE OP16 LDU
  320. $9F OP16 STX   $DF OP16 STU
  321. : CMPD SUBD flag10 ; : CMPY CMPX flag10 ;
  322. : LDY  LDX  flag10 ; : STY  STX  flag10 ;
  323. : LDS  LDU  flag10 ; : STS  STU  flag10 ;
  324. : CMPU SUBD flag11 ; : CMPS CMPX flag11 ;
  325.  
  326. \ Structured assembler constructs.
  327. : IF >R A; R> C, >MARK ;
  328. : THEN A; >RESOLVE ;
  329. : ELSE A; $20 C, >MARK SWAP >RESOLVE ;
  330. : BEGIN A; <MARK ;
  331. : UNTIL >R A; R> C, <RESOLVE ;
  332. : WHILE >R A; R> C, >MARK ;
  333. : REPEAT A; $20 C, SWAP <RESOLVE >RESOLVE ;
  334. : AGAIN $20 UNTIL ;
  335. $22 CONSTANT U<= $23 CONSTANT U>
  336. $24 CONSTANT U<  $25 CONSTANT U>=
  337. $26 CONSTANT 0=  $27 CONSTANT 0<>
  338. $28 CONSTANT VS  $29 CONSTANT VC
  339. $2A CONSTANT 0<  $2B CONSTANT 0>=
  340. $2C CONSTANT <   $2D CONSTANT >=
  341. $2E CONSTANT <=  $2F CONSTANT >
  342.  
  343. ' VC, IS C,
  344. ' V, IS ,
  345. ' VHERE IS HERE
  346. ' VALLOT IS ALLOT
  347.  
  348. : ENDASM \ End assembly.
  349.   A; FORTH DEFINITIONS ;
  350. FORTH DEFINITIONS
  351. : ASSEMBLE \ Start assembly.
  352.   6809ASM DEFINITIONS NOINSTR ;
  353. ONLY FORTH ALSO extensions also forth DEFINITIONS
  354.  
  355. \ 6809 Simulator.
  356.  
  357. VOCABULARY 6809SIM 6809SIM ALSO DEFINITIONS
  358.  
  359. \ Processor registers.
  360. VARIABLE AREG VARIABLE BREG
  361. VARIABLE CCREG VARIABLE DPREG VARIABLE PCREG
  362. VARIABLE XREG VARIABLE YREG VARIABLE UREG VARIABLE SREG
  363. VARIABLE IREG \ Instruction register.
  364. : DREG@ ( --- n)
  365.   AREG @ $ff and 8 lshift BREG @ $ff and + ;
  366. : DREG! ( n ---)
  367.   DUP 255 AND BREG ! 8 rshift 255 AND AREG ! ;
  368. : IMM-BYTE ( --- c) \ Get byte at program counter and increment PC.
  369.   PCREG @ VC@ 1 PCREG +! ;
  370. : IMM-WORD ( --- n) \ Get word at program counter and increment PC.
  371.   PCREG @ V@  2 pcreg +! ;
  372. : PSHSBYTE ( c ---) \ Push byte on stack.
  373.   -1 SREG +! SREG @ VC! ;
  374. : PSHSWORD ( n ---) \ Push word on stack.
  375.   -2 SREG +! SREG @ V! ;
  376. : PULSBYTE ( --- c) \ Pull byte from stack.
  377.   SREG @ VC@ 1 SREG +! ;
  378. : PULSWORD ( --- n) \ Pull word from stack.
  379.   SREG @ V@  2 SREG +! ;
  380.  
  381. : SIGNED ( c --- n) \ Make signed number from signed byte.
  382.   DUP 128 AND IF 256 - THEN ;
  383.  
  384. CREATE IXREGS XREG , YREG , UREG , SREG ,
  385. VARIABLE INDEX
  386.  
  387. : ,R+ ( --- addr)
  388.   INDEX @ @  1 INDEX @ +! ;
  389. : ,R++ ( --- addr)
  390.   INDEX @ @  2 INDEX @ +! ;
  391. : ,-R  ( --- addr)
  392.   -1 INDEX @ +!  INDEX @ @ ;
  393. : ,--R ( --- addr)
  394.   -2 INDEX @ +!  INDEX @ @ ;
  395. : ,R ( --- addr)
  396.   INDEX @ @ ;
  397. : A,R ( --- addr)
  398.   INDEX @ @ AREG @ $ff and SIGNED + ;
  399. : B,R ( --- addr)
  400.   INDEX @ @ BREG @ $ff and SIGNED + ;
  401. : N,R ( --- addr)
  402.   INDEX @ @ IMM-BYTE SIGNED + ;
  403. : NN,R ( ---addr)
  404.   INDEX @ @ IMM-WORD + ;
  405. : D,R ( --- addr)
  406.   INDEX @ @ DREG@ + ;
  407. : N,PCR ( --- addr)
  408.   IMM-BYTE SIGNED PCREG @ + ;
  409. : NN,PCR ( --- addr)
  410.   IMM-WORD PCREG @ + ;
  411.  
  412. CREATE PBTABLE ' ,R+ , ' ,R++ , ' ,-R , ' ,--R ,
  413.                ' ,R ,  ' B,R  , ' A,R ,  ' FALSE ,
  414.                ' N,R , ' NN,R , ' FALSE , ' D,R ,
  415.                ' N,PCR , ' NN,PCR , ' FALSE , ' IMM-WORD ,
  416.  
  417. : POSTBYTE ( --- addr) \ Postbyte addressing forms.
  418.   IMM-BYTE DUP $60 AND 5 rshift cells IXREGS + @ INDEX !
  419.   DUP $80 AND IF \ Not 5-bit format.
  420.      DUP >R $0F AND cells PBTABLE + @ EXECUTE \ Perform indexing.
  421.      R> $10 AND IF V@ THEN \ Add indirection if necessary.
  422.   ELSE \ 5-bit format.
  423.      $1F AND DUP $10 AND IF $FFF0 OR THEN \ Sign extend 5 bits.
  424.      INDEX @ @ +
  425.   THEN ;
  426.  
  427. : IMM8 ( --- addr) \ Immediate addressing 8 bits.
  428.   PCREG @ 1 PCREG +! ;
  429. : IMM16 ( --- addr) \ Immediate addressing 16 bits.
  430.   PCREG @ 2 PCREG +! ;
  431. : DIRECT ( --- addr) \ Direct addressing.
  432.   IMM-BYTE DPREG @ $ff and 8 lshift + ;
  433. CREATE E0TABLE ' DIRECT , ' FALSE , ' POSTBYTE , ' IMM-WORD ,
  434. : EADDR0 ( --- addr) \ Get effective address for NEG...CLR instructions.
  435.   IREG @ $30 AND 4 rshift cells E0TABLE + @ EXECUTE ;
  436. CREATE E8TABLE ' IMM8 , ' DIRECT , ' POSTBYTE , ' IMM-WORD ,
  437. : EADDR8 ( --- addr) \ Get effective address for 8-bits instructions.
  438.   IREG @ $30 AND 4 rshift cells E8TABLE + @ EXECUTE ;
  439. CREATE E16TABLE ' IMM16 , ' DIRECT , ' POSTBYTE , ' IMM-WORD ,
  440. : EADDR16 ( --- addr) \ Get effective address for 16-bits instructions.
  441.   IREG @ $30 AND 4 rshift cells E16TABLE + @ EXECUTE ;
  442. : ??? \ Illegal opcode.
  443.   7 EMIT ;
  444.  
  445.  
  446. : SEC \ Set carry flag.
  447.   CCREG @ 1 OR CCREG ! ;
  448. : CLC \ Clear carry flag.
  449.   CCREG @ $FE AND CCREG ! ;
  450. : SEZ \ Set zero flag.
  451.   CCREG @ 4 OR CCREG ! ;
  452. : CLZ \ Clear zero flag.
  453.   CCREG @ $FB AND CCREG ! ;
  454. : SEN \ Set sign flag.
  455.   CCREG @ 8 OR CCREG ! ;
  456. : CLN \ Clear sign flag.
  457.   CCREG @ $F7 AND CCREG ! ;
  458. : SEV \ Set overflow flag.
  459.   CCREG @ 2 OR CCREG ! ;
  460. : CLV \ Clear overflow flag.
  461.   CCREG @ $FD AND CCREG ! ;
  462. : SEH \ Set halfcarry flag.
  463.   CCREG @ 32 OR CCREG ! ;
  464. : CLH \ Clear halfcarry flag.
  465.   CCREG @ $DF AND CCREG ! ;
  466.  
  467. : SETNZ8 \ Set zero and sign flag after 8-bit operation.
  468.   DUP 255 AND IF CLZ ELSE SEZ THEN
  469.   DUP 128 AND IF SEN ELSE CLN THEN ;
  470. : SETNZ16 \ Set zero and sign flags after 16-bit operation.
  471.   DUP $ffff and IF CLZ ELSE SEZ THEN
  472.   DUP $8000 and IF SEN ELSE CLN THEN ;
  473.  
  474. : SETSTATUS ( n1 n2 n3 --- n3)
  475. \ Set status bits dependent on result of arithmetic function.
  476.   3DUP XOR XOR  $10 AND IF SEH ELSE CLH THEN
  477.   DUP >R DUP 2/ XOR XOR XOR $80 AND IF SEV ELSE CLV THEN
  478.   R> DUP $100 AND IF SEC ELSE CLC THEN
  479.   SETNZ8 ;
  480.  
  481. : (ADD) ( n1 n2 --- n3) \ Add 8 bits and set status.
  482.   2DUP + SETSTATUS ;
  483. : (ADC) ( n1 n2 --- n3) \ Add with carry 8 bits and set status.
  484.   2DUP + CCREG @ 1 AND + SETSTATUS ;
  485. : (SUB) ( n1 n2 --- n3) \ Subtract 8 bits and set status.
  486.   2DUP - SETSTATUS ;
  487. : (SBC) ( n1 n2 --- n3) \ Subtract with carry 8 bits and set status.
  488.   2DUP - CCREG @ 1 AND - SETSTATUS ;
  489. : ADDA
  490.   AREG @ $ff and EADDR8 VC@ (ADD) AREG ! ;
  491. : ADDB
  492.   BREG @ $ff and EADDR8 VC@ (ADD) BREG ! ;
  493. : ADCA
  494.   AREG @ $ff and EADDR8 VC@ (ADC) AREG ! ;
  495. : ADCB
  496.   BREG @ $ff and EADDR8 VC@ (ADC) BREG ! ;
  497. : SUBA
  498.   AREG @ $ff and EADDR8 VC@ (SUB) AREG ! ;
  499. : SUBB
  500.   BREG @ $ff and EADDR8 VC@ (SUB) BREG ! ;
  501. : SBCA
  502.   AREG @ $ff and EADDR8 VC@ (SBC) AREG ! ;
  503. : SBCB
  504.   BREG @ $ff and EADDR8 VC@ (SBC) BREG ! ;
  505. : CMPA
  506.   AREG @ $ff and EADDR8 VC@ (SUB) DROP ;
  507. : CMPB
  508.   BREG @ $ff and EADDR8 VC@ (SUB) DROP ;
  509.  
  510. : (AND) ( n1 n2 --- n3) \ AND and set status.
  511.   AND SETNZ8 CLV ;
  512. : (OR) ( n1 n2 --- n3)  \ OR and set status.
  513.   OR SETNZ8 CLV ;
  514. : (EOR) ( n1 n2 --- n3) \ Exclusive OR and set status.
  515.   XOR SETNZ8 CLV ;
  516. : ANDA
  517.   AREG @ $ff and EADDR8 VC@ (AND) AREG ! ;
  518. : ANDB
  519.   BREG @ $ff and EADDR8 VC@ (AND) BREG ! ;
  520. : ORA
  521.   AREG @ $ff and EADDR8 VC@ (OR) AREG ! ;
  522. : ORB
  523.   BREG @ $ff and EADDR8 VC@ (OR) BREG ! ;
  524. : EORA
  525.   AREG @ $ff and EADDR8 VC@ (EOR) AREG ! ;
  526. : EORB
  527.   BREG @ $ff and EADDR8 VC@ (EOR) BREG ! ;
  528. : BITA
  529.   AREG @ $ff and EADDR8 VC@ (AND) DROP ;
  530. : BITB
  531.   BREG @ $ff and EADDR8 VC@ (AND) DROP ;
  532.  
  533. : LDA
  534.   EADDR8 VC@ SETNZ8 CLV AREG ! ;
  535. : LDB
  536.   EADDR8 VC@ SETNZ8 CLV BREG ! ;
  537. : STA
  538.   AREG @ $ff and SETNZ8 CLV EADDR8 VC! ;
  539. : STB
  540.   BREG @ $ff and SETNZ8 CLV EADDR8 VC! ;
  541.  
  542. : JSR
  543.   EADDR8  PCREG @ PSHSWORD  PCREG ! ;
  544.  
  545. : (NEG) ( n --- -n ) \ Negate n and set status register.
  546.   0 SWAP (SUB) ;
  547. : NEGA
  548.   AREG @ $ff and (NEG) AREG ! ;
  549. : NEGB
  550.   BREG @ $ff and (NEG) BREG ! ;
  551. : NEG
  552.   EADDR0 DUP VC@ (NEG) SWAP VC! ;
  553. : (COM) ( n --- nXOR-1) \ Comsplement n and set status register.
  554.   NOT  SETNZ8 SEC CLV ;
  555. : COMA
  556.   AREG @ $ff and (COM) AREG ! ;
  557. : COMB
  558.   BREG @ $ff and (COM) BREG ! ;
  559. : COM
  560.   EADDR0 DUP VC@ (COM) SWAP VC! ;
  561. : (LSR) ( n --- n/2 ) \ Logic shift right and set status.
  562.   DUP 1 AND IF SEC ELSE CLC THEN
  563.   2/ SETNZ8 ;
  564. : LSRA
  565.   AREG @ $ff and (LSR) AREG ! ;
  566. : LSRB
  567.   BREG @ $ff and (LSR) BREG ! ;
  568. : LSR
  569.   EADDR0 DUP VC@ (LSR) SWAP VC! ;
  570. : (ROR) ( n --- n ROT right) \ Rotate right and set status.
  571.   CCREG @ 1 AND >R
  572.   DUP 1 AND IF SEC ELSE CLC THEN
  573.   2/ R> IF $80 OR THEN SETNZ8 ;
  574. : RORA
  575.   AREG @ $ff and (ROR) AREG ! ;
  576. : RORB
  577.   BREG @ $ff and (ROR) BREG ! ;
  578. : ROR
  579.   EADDR0 DUP VC@ (ROR) SWAP VC! ;
  580. : (ASR) ( n --- n/2) \ Arithmetic shift right and set status.
  581.   DUP 1 AND IF SEC ELSE CLC THEN
  582.   2/ DUP $40 AND IF $80 OR THEN
  583.   DUP $10 AND IF SEH ELSE CLH THEN SETNZ8 ;
  584. : ASRA
  585.   AREG @ $ff and (ASR) AREG ! ;
  586. : ASRB
  587.   BREG @ $ff and (ASR) BREG ! ;
  588. : ASR
  589.   EADDR0 DUP VC@ (ASR) SWAP VC! ;
  590. : (ASL) ( n --- n*2) \ Arithmetic (logic) shift left.
  591.   DUP (ADD) ;
  592. : ASLA
  593.   AREG @ $ff and (ASL) AREG ! ;
  594. : ASLB
  595.   BREG @ $ff and (ASL) BREG ! ;
  596. : ASL
  597.   EADDR0 DUP VC@ (ASL) SWAP VC! ;
  598. : (ROL) ( n --- n ROT left) \ Rotate left.
  599.   CCREG @ 1 AND >R
  600.   DUP $80 AND IF SEC ELSE CLC THEN
  601.   2* DUP $80 AND IF SEV ELSE CLV THEN
  602.   R> OR SETNZ8 ;
  603. : ROLA
  604.   AREG @ $ff and (ROL) AREG ! ;
  605. : ROLB
  606.   BREG @ $ff and (ROL) BREG ! ;
  607. : ROL
  608.   EADDR0 DUP VC@ (ROL) SWAP VC! ;
  609. : (DEC) ( n --- n-1) \ Decrement and set status.
  610.   1- DUP $7F = IF SEV ELSE CLV THEN SETNZ8 ;
  611. : DECA
  612.   AREG @ $ff and (DEC) AREG ! ;
  613. : DECB
  614.   BREG @ $ff and (DEC) BREG ! ;
  615. : DEC
  616.   EADDR0 DUP VC@ (DEC) SWAP VC! ;
  617. : (INC) ( n --- n+1) \ Increment and set status.
  618.   1+ DUP $80 = IF SEV ELSE CLV THEN SETNZ8 ;
  619. : INCA
  620.   AREG @ $ff and (INC) AREG ! ;
  621. : INCB
  622.   BREG @ $ff and (INC) BREG ! ;
  623. : INC
  624.   EADDR0 DUP VC@ (INC) SWAP VC! ;
  625. : (TST) ( n --- ) \ Test and set status.
  626.   SETNZ8 CLV DROP ;
  627. : TSTA
  628.   AREG @ $ff and (TST) ;
  629. : TSTB
  630.   BREG @ $ff and (TST) ;
  631. : TST
  632.   EADDR0 VC@ (TST) ;
  633. : JMP
  634.   EADDR0 PCREG ! ;
  635. : (CLR) ( --- 0) \ Set the status flags as n CLR statement.
  636.   SEZ CLN CLV CLC 0 ;
  637. : CLRA
  638.   (CLR) AREG ! ;
  639. : CLRB
  640.   (CLR) BREG ! ;
  641. : CLR
  642.   (CLR) EADDR0 VC! ;
  643. : BSR
  644.   IMM-BYTE
  645.   PCREG @ PSHSWORD
  646.   SIGNED PCREG +! ;
  647.  
  648. VARIABLE (INSTRTABLE)
  649. VARIABLE FLAG 0 FLAG !
  650. : 0FL
  651.   1 FLAG !
  652.   IMM-BYTE DUP IREG ! cells (INSTRTABLE) @ + @ EXECUTE 0 FLAG ! ;
  653. : 1FL
  654.   2 FLAG !
  655.   IMM-BYTE DUP IREG ! cells (INSTRTABLE) @ + @ EXECUTE 0 FLAG ! ;
  656.  
  657. : NOP ;
  658. : SYNC ;
  659. : LBRA
  660.   IMM-WORD PCREG +! ;
  661. : LBSR
  662.   IMM-WORD
  663.   PCREG @ PSHSWORD
  664.   PCREG +! ;
  665. : DAA
  666.   AREG @ $ff and AREG !
  667.   CCREG @ $20 AND IF 6 AREG +! THEN
  668.   AREG @ $0F AND 9 > IF 6 AREG +! THEN
  669.   CCREG @ 1 AND IF $60 AREG +! THEN
  670.   AREG @ $F0 AND $90 > IF $60 AREG +! THEN
  671.   AREG @ 255 U> IF SEC THEN ;
  672. : ORCC
  673.   IMM-BYTE CCREG @ OR CCREG ! ;
  674. : ANDCC
  675.   IMM-BYTE CCREG @ AND CCREG ! ;
  676. : MUL
  677.   AREG @ $ff and BREG @ $ff and * DUP DREG!
  678.   DUP $ffff and IF CLZ ELSE SEZ THEN
  679.   $FF00 AND IF SEC ELSE CLC THEN ;
  680. : SEX
  681.   BREG @ $ff and SIGNED SETNZ16 DREG! ;
  682. : ABX
  683.   BREG @ $ff and XREG +! ;
  684. : RTS
  685.   PULSWORD PCREG ! ;
  686. : RTI
  687.   CCREG @ $80 AND
  688.   PULSBYTE CCREG !
  689.   IF
  690.    PULSBYTE AREG !
  691.    PULSBYTE BREG !
  692.    PULSBYTE DPREG !
  693.    PULSWORD XREG !
  694.    PULSWORD YREG !
  695.    PULSWORD UREG !
  696.   THEN
  697.   PULSWORD PCREG ! ;
  698. : PSHALL \ Push all the registers.
  699.   PCREG @ PSHSWORD
  700.   UREG @  PSHSWORD
  701.   YREG @  PSHSWORD
  702.   XREG @  PSHSWORD
  703.   DPREG @ PSHSBYTE
  704.   BREG @ PSHSBYTE
  705.   AREG @ PSHSBYTE
  706.   CCREG @ PSHSBYTE ;
  707.  
  708. : SWI
  709.   PSHALL
  710.   CCREG @ $80 OR FLAG @ 0= IF $50 OR THEN CCREG !
  711.   CASE FLAG @
  712.   0 OF $FFFA ENDOF
  713.   1 OF $FFF4 ENDOF
  714.   2 OF $FFF2 ENDOF
  715.   ENDCASE V@ PCREG ! ;
  716.  
  717. : IRQ \ Perform interrupt.
  718.   CCREG @ $10 AND 0= IF
  719.    PSHALL
  720.    CCREG @ $90 OR CCREG !
  721.    $FFF8 V@ PCREG !
  722.   THEN ;
  723. : NMI \ Perform nonmaskable interrupt.
  724.   PSHALL
  725.   CCREG @ $D0 OR CCREG !
  726.   $FFFC V@ PCREG ! ;
  727. : FIRQ \ Perform Fast interrupt.
  728.   CCREG @ $40 AND 0= IF
  729.    PCREG @ PSHSWORD
  730.    CCREG @ PSHSBYTE
  731.    CCREG @ $7F AND $50 OR CCREG !
  732.    $FFF6 V@ PCREG !
  733.   THEN ;
  734. : RESET \ Reset processor.
  735.   CCREG @ $D0 OR CCREG !
  736.   $FFFE V@ PCREG ! ;
  737.  
  738. : CWAI
  739.   ANDCC
  740.   IRQ ;
  741.  
  742. VARIABLE ---
  743. CREATE REGS --- , XREG , YREG , UREG , SREG , PCREG , --- , --- ,
  744.             AREG , BREG , CCREG , DPREG , --- , --- , --- , --- ,
  745. : REG@ ( c --- n) \  Get value from register c
  746.   DUP IF cells REGS + @ @ ELSE DROP DREG@ THEN ;
  747. : REG! ( n c ---) \ Store n into register c
  748.   DUP IF cells REGS + @ ! ELSE DROP DREG! THEN ;
  749. : EXG
  750.   IMM-BYTE DUP 4 rshift SWAP $0F AND \ Get register numbers.
  751.   2DUP REG@ >R REG@ SWAP REG! R> SWAP REG! ;
  752. : TFR
  753.   IMM-BYTE DUP $0F AND SWAP 4 rshift REG@ SWAP REG! ;
  754.  
  755. : (BR) ( f ---) \ Perform a conditional branch.
  756.   FLAG @ IF \ Is it a long branch?
  757.    IF  IMM-WORD PCREG +!
  758.    ELSE       2 PCREG +!
  759.    THEN
  760.   ELSE
  761.    IF  IMM-BYTE SIGNED PCREG +!
  762.    ELSE              1 PCREG +!
  763.    THEN
  764.   THEN ;
  765.  
  766. : NXORV ( --- f) \ Exclusive or of N and V flag, indicating 'less than'
  767.   CCREG @ DUP $08 AND 0<> SWAP $02 AND 0<> XOR ;
  768.  
  769. : BRA
  770.   TRUE (BR) ;
  771. : BRN
  772.   FALSE (BR) ;
  773. : BHI  \ branch if carry and zero both 0.
  774.   CCREG @ $05 AND 0= (BR) ;
  775. : BLS
  776.   CCREG @ $05 AND (BR) ;
  777. : BCC
  778.   CCREG @ $01 AND 0= (BR) ;
  779. : BCS
  780.   CCREG @ $01 AND (BR) ;
  781. : BNE
  782.   CCREG @ $04 AND 0= (BR) ;
  783. : BEQ
  784.   CCREG @ $04 AND (BR) ;
  785. : BVC
  786.   CCREG @ $02 AND 0= (BR) ;
  787. : BVS
  788.   CCREG @ $02 AND (BR) ;
  789. : BPL
  790.   CCREG @ $08 AND 0= (BR) ;
  791. : BMI
  792.   CCREG @ $08 AND (BR) ;
  793. : BGE
  794.   NXORV 0= (BR) ;
  795. : BLT
  796.   NXORV (BR) ;
  797. : BGT
  798.   NXORV CCREG @ $04 AND OR 0= (BR) ;
  799. : BLE
  800.   NXORV CCREG @ $04 AND OR (BR) ;
  801.  
  802. : LEAX
  803.   POSTBYTE $ffff and DUP IF CLZ ELSE SEZ THEN
  804.   XREG ! ;
  805. : LEAY
  806.   POSTBYTE $ffff and DUP IF CLZ ELSE SEZ THEN
  807.   YREG ! ;
  808. : LEAS
  809.   POSTBYTE SREG ! ;
  810. : LEAU
  811.   POSTBYTE UREG ! ;
  812.  
  813. : SWAPUS \ Swap contents of U and S registers.
  814.   UREG @ SREG @ UREG ! SREG ! ;
  815.  
  816. : PSHS
  817.   IMM-BYTE
  818.   DUP 128 AND IF PCREG @  PSHSWORD THEN
  819.   DUP  64 AND IF UREG  @  PSHSWORD THEN
  820.   DUP  32 AND IF YREG  @  PSHSWORD THEN
  821.   DUP  16 AND IF XREG  @  PSHSWORD THEN
  822.   DUP   8 AND IF DPREG @  PSHSBYTE THEN
  823.   DUP   4 AND IF BREG  @ PSHSBYTE THEN
  824.   DUP   2 AND IF AREG  @ PSHSBYTE THEN
  825.         1 AND IF CCREG @ PSHSBYTE THEN ;
  826.  
  827. : PULS
  828.   IMM-BYTE
  829.   DUP   1 AND IF PULSBYTE CCREG ! THEN
  830.   DUP   2 AND IF PULSBYTE AREG  ! THEN
  831.   DUP   4 AND IF PULSBYTE BREG  ! THEN
  832.   DUP   8 AND IF PULSBYTE DPREG ! THEN
  833.   DUP  16 AND IF PULSWORD XREG   ! THEN
  834.   DUP  32 AND IF PULSWORD YREG   ! THEN
  835.   DUP  64 AND IF PULSWORD UREG   ! THEN
  836.       128 AND IF PULSWORD PCREG  ! THEN ;
  837.  
  838. : PSHU
  839.   SWAPUS PSHS SWAPUS ;
  840. : PULU
  841.   SWAPUS PULS SWAPUS ;
  842.  
  843. : SETSTATUSD ( n1 n2 n3 cy --- n3 ) \ Set flags according to 16bit operation
  844.   IF SEC $8000 ELSE CLC 0 THEN
  845.   \ Start with carry in bit 15.
  846.   OVER >R \ Preserve result.
  847.   XOR XOR XOR $8000 AND \ Xor carry, orerands and result, giving overflow bit.
  848.   IF SEV ELSE CLV THEN
  849.   R> SETNZ16 ;
  850.  
  851. : ADDD
  852.   DREG@ EADDR16 V@ 2DUP + dup $10000 and SETSTATUSD DREG! ;
  853. : SUBD
  854.   FLAG @ 2 = IF UREG @ $ffff and ELSE DREG@ THEN
  855.   EADDR16 V@  2DUP - dup $10000 and SETSTATUSD
  856.   FLAG @ IF DROP ELSE DREG! THEN ;
  857. : LDD
  858.   EADDR16 V@ SETNZ16 DREG! ;
  859. : STD
  860.   DREG@ SETNZ16 EADDR16 V! ;
  861. : LDX
  862.   EADDR16 V@ SETNZ16  FLAG @ IF YREG ELSE XREG THEN  ! ;
  863. : STX
  864.   FLAG @ IF YREG ELSE XREG THEN  @  SETNZ16 EADDR16 V! ;
  865. : LDU
  866.   EADDR16 V@ SETNZ16  FLAG @ IF SREG ELSE UREG THEN  ! ;
  867. : STU
  868.   FLAG @ IF SREG ELSE UREG THEN  @  SETNZ16 EADDR16 V! ;
  869. : CMPX
  870.   CASE FLAG @
  871.   0 OF XREG ENDOF
  872.   1 OF YREG ENDOF
  873.   2 OF SREG ENDOF
  874.   ENDCASE @ $ffff and
  875.   EADDR16 V@ 2DUP - dup $10000 and SETSTATUSD DROP ;
  876.  
  877.  
  878. CREATE INSTRTABLE INSTRTABLE (INSTRTABLE) !
  879. ' NEG , ' ??? , ' ??? , ' COM , ' LSR , ' ??? , ' ROR , ' ASR ,
  880. ' ASL , ' ROL , ' DEC , ' ??? , ' INC , ' TST , ' JMP , ' CLR ,
  881. ' 0FL , ' 1FL , ' NOP , ' SYNC , ' ??? , ' ??? , ' LBRA , ' LBSR ,
  882. ' ??? , ' DAA , ' ORCC , ' ??? , ' ANDCC , ' SEX , ' EXG , ' TFR ,
  883. ' BRA , ' BRN , ' BHI , ' BLS , ' BCC , ' BCS , ' BNE , ' BEQ ,
  884. ' BVC , ' BVS , ' BPL , ' BMI , ' BGE , ' BLT , ' BGT , ' BLE ,
  885. ' LEAX , ' LEAY , ' LEAS , ' LEAU , ' PSHS , ' PULS , ' PSHU , ' PULU ,
  886. ' ??? , ' RTS , ' ABX , ' RTI , ' CWAI , ' MUL , ' ??? , ' SWI ,
  887. ' NEGA , ' ??? , ' ??? , ' COMA , ' LSRA , ' ??? , ' RORA , ' ASRA ,
  888. ' ASLA , ' ROLA , ' DECA , ' ??? , ' INCA , ' TSTA , ' ??? , ' CLRA ,
  889. ' NEGB , ' ??? , ' ??? , ' COMB , ' LSRB , ' ??? , ' RORB , ' ASRB ,
  890. ' ASLB , ' ROLB , ' DECB , ' ??? , ' INCB , ' TSTB , ' ??? , ' CLRB ,
  891. ' NEG , ' ??? , ' ??? , ' COM , ' LSR , ' ??? , ' ROR , ' ASR ,
  892. ' ASL , ' ROL , ' DEC , ' ??? , ' INC , ' TST , ' JMP , ' CLR ,
  893. ' NEG , ' ??? , ' ??? , ' COM , ' LSR , ' ??? , ' ROR , ' ASR ,
  894. ' ASL , ' ROL , ' DEC , ' ??? , ' INC , ' TST , ' JMP , ' CLR ,
  895. ' SUBA , ' CMPA , ' SBCA , ' SUBD , ' ANDA , ' BITA , ' LDA , ' STA ,
  896. ' EORA , ' ADCA , ' ORA , ' ADDA , ' CMPX , ' BSR , ' LDX , ' STX ,
  897. ' SUBA , ' CMPA , ' SBCA , ' SUBD , ' ANDA , ' BITA , ' LDA , ' STA ,
  898. ' EORA , ' ADCA , ' ORA , ' ADDA , ' CMPX , ' JSR , ' LDX , ' STX ,
  899. ' SUBA , ' CMPA , ' SBCA , ' SUBD , ' ANDA , ' BITA , ' LDA , ' STA ,
  900. ' EORA , ' ADCA , ' ORA , ' ADDA , ' CMPX , ' JSR , ' LDX , ' STX ,
  901. ' SUBA , ' CMPA , ' SBCA , ' SUBD , ' ANDA , ' BITA , ' LDA , ' STA ,
  902. ' EORA , ' ADCA , ' ORA , ' ADDA , ' CMPX , ' JSR , ' LDX , ' STX ,
  903. ' SUBB , ' CMPB , ' SBCB , ' ADDD , ' ANDB , ' BITB , ' LDB , ' STB ,
  904. ' EORB , ' ADCB , ' ORB , ' ADDB , ' LDD , ' STD , ' LDU , ' STU ,
  905. ' SUBB , ' CMPB , ' SBCB , ' ADDD , ' ANDB , ' BITB , ' LDB , ' STB ,
  906. ' EORB , ' ADCB , ' ORB , ' ADDB , ' LDD , ' STD , ' LDU , ' STU ,
  907. ' SUBB , ' CMPB , ' SBCB , ' ADDD , ' ANDB , ' BITB , ' LDB , ' STB ,
  908. ' EORB , ' ADCB , ' ORB , ' ADDB , ' LDD , ' STD , ' LDU , ' STU ,
  909. ' SUBB , ' CMPB , ' SBCB , ' ADDD , ' ANDB , ' BITB , ' LDB , ' STB ,
  910. ' EORB , ' ADCB , ' ORB , ' ADDB , ' LDD , ' STD , ' LDU , ' STU ,
  911.  
  912. : SINGLE-STEP  \ Perform one instruction.
  913.   IMM-BYTE    \ Get instruction.
  914.   DUP IREG !   \ Store into instruction register for later use.
  915.   cells INSTRTABLE + @ \ Lookup inbstruction in table.
  916.   EXECUTE ;
  917.  
  918. VARIABLE BPREG \ Breakpoint address.
  919. : BREAKPOINT ( addr --- ) \ Preform instructions until breakpoint.
  920.   BPREG @
  921.   BEGIN
  922.    SINGLE-STEP
  923.    DUP PCREG @ $ffff and =
  924.   UNTIL DROP ;
  925.  
  926. : FEMIT dup $60 and 0= if drop [char] . then emit ;
  927.  
  928. : HDIGIT. ( c ---) \ Print hex digit.
  929.   $0F AND DUP 9 > IF 7 + THEN $30 + FEMIT ;
  930.  
  931. : B. ( c ---) \ Print byte hexadecimal.
  932.   DUP 4 rshift HDIGIT. HDIGIT. ;
  933. : H. ( n ---) \ Print word hexadecimal.
  934.   DUP 8 rshift B. B. 1 SPACES ;
  935. : BIN. ( c ---) \ Print byte binary.
  936.   BASE @ 2 BASE ! SWAP 0 <# # # # # # # # # #> TYPE SPACE BASE ! ;
  937. VARIABLE CURSOR
  938. : SHOWPAGE ( n ---) \ Show page at addr n.
  939.   0 0 AT-XY
  940.   ."        0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F"
  941.   ."  0123456789ABCDEF"
  942.    256 BOUNDS DO
  943.    CR I H. SPACE
  944.    16 0 DO I J + $ffff and DUP CURSOR @ = IF
  945.                     reVERSE VC@ B. -reVERSE \ Type cursor inverse.
  946.                   ELSE VC@ B.
  947.                   THEN
  948.                   1 SPACES
  949.         LOOP
  950.    16 0 DO I J + VC@ FEMIT
  951.         LOOP
  952.   16 +LOOP CR ;
  953.  
  954. \ 6809 Disassembler.
  955. VARIABLE IP \ Instruction pointer.
  956. VARIABLE INSTR \ Instruction.
  957.  
  958. : DIRECTDIS \ Disassemble direct address.
  959.   IP @ VC@  1 IP +!  ." $" B. ;
  960. : EXTENDEDDIS \ Disassemble extended address.
  961.   IP @ V@   2 IP +!  ." $" H. ;
  962. : BINDIS \ Disassemble binary argument.
  963.   IP @ VC@  1 IP +!  ." % " BIN. ;
  964. : RELDIS \ Disassemble realtive branch address.
  965.   IP @ VC@  1 IP +!  SIGNED IP @ + ." $" H. ;
  966. : LONGRELDIS \ Disassemble long relative branch.
  967.   IP @ V@   2 IP +!  IP @ + ." $" H. ;
  968. : IMMDIS \ Disassemble immediate operand.
  969.   INSTR @ $8D =
  970.    IF RELDIS \ Exception for BSR instruction.
  971.    ELSE ." # " INSTR @ $0F AND DUP 3 = SWAP $0C AND $0C = OR
  972.      IF \ 16 bits instruction.
  973.         IP @ V@  2 IP +!  ." $" H.
  974.      ELSE \ 8 bits instruction.
  975.         IP @ VC@ 1 IP +!  ." $" B.
  976.      THEN
  977.    THEN ;
  978.  
  979. VARIABLE 1STREG \ First register to be printed?
  980. : PPREG. ( regnr ---) \ Type register name for PSH and PUL instructions.
  981.   1STREG @ IF 1STREG OFF ELSE ." , " THEN
  982.   CASE
  983.    0 OF ." PC" ENDOF
  984.    1 OF INSTR @ 2 AND IF ." S" ELSE ." U" THEN ENDOF
  985.    2 OF ." Y" ENDOF
  986.    3 OF ." X" ENDOF
  987.    4 OF ." DP" ENDOF
  988.    5 OF ." B" ENDOF
  989.    6 OF ." A" ENDOF
  990.    7 OF ." CC" ENDOF
  991.   ENDCASE ;
  992.  
  993. : PSHPULDIS \ Disassemble rigister set after PSH and PUL instructions.
  994.   IP @ VC@  1 IP +!
  995.    1STREG ON
  996.    8 0 DO DUP $80 AND IF I PPREG. THEN 2* LOOP DROP ;
  997.  
  998. : ETREG. ( regnr ---) \ Type register name for TFR and EXG instructions.
  999.   CASE
  1000.    0 OF ." D" ENDOF
  1001.    1 OF ." X" ENDOF
  1002.    2 OF ." Y" ENDOF
  1003.    3 OF ." U" ENDOF
  1004.    4 OF ." S" ENDOF
  1005.    5 OF ." PC" ENDOF
  1006.    8 OF ." A" ENDOF
  1007.    9 OF ." B" ENDOF
  1008.    10 OF ." CC" ENDOF
  1009.    11 OF ." DP" ENDOF
  1010.      ." ?"
  1011.   ENDCASE ;
  1012. : EXGTFRDIS \ Disassemble registers after EXG and TFR instructions.
  1013.   IP @ VC@  1 IP +!
  1014.   DUP 4 rshift ETREG. ." , " $0F AND ETREG. ;
  1015.  
  1016. : INDEXREG. \ Type the index register.
  1017.   CASE INDEX @
  1018.    $00 OF ." X" ENDOF
  1019.    $20 OF ." Y" ENDOF
  1020.    $40 OF ." U" ENDOF
  1021.    $60 OF ." S" ENDOF
  1022.   ENDCASE ;
  1023.  
  1024. : 16signed ( n --- n2) 
  1025.   dup $8000 and if $ffff0000 or then ;
  1026.  
  1027. : PBDIS \ Disassemble instructions with postbyte.
  1028.   IP @ VC@  1 IP +!
  1029.   DUP $60 AND INDEX !
  1030.   DUP $80 < IF \ 5-bit format.
  1031.    $1F AND DUP $10 AND IF $FFF0 OR THEN 16signed . ." ," INDEXREG.
  1032.   ELSE
  1033.    DUP $0F AND
  1034.    CASE
  1035.     0 OF ." ," INDEXREG. ." +" ENDOF
  1036.     1 OF ." ," INDEXREG. ." ++" ENDOF
  1037.     2 OF ." ,-" INDEXREG. ENDOF
  1038.     3 OF ." ,--" INDEXREG. ENDOF
  1039.     4 OF ." 0 ," INDEXREG. ENDOF
  1040.     5 OF ." B," INDEXREG. ENDOF
  1041.     6 OF ." A," INDEXREG. ENDOF
  1042.     8 OF IP @ VC@ 1 IP +! SIGNED . ." ," INDEXREG. ENDOF
  1043.     9 OF IP @ V@  2 IP +! 16signed . ." ," INDEXREG. ENDOF
  1044.    $B OF ." D," INDEXREG. ENDOF
  1045.    $C OF RELDIS ." ,PCR" ENDOF
  1046.    $D OF LONGRELDIS ." ,PCR" ENDOF
  1047.    $F OF EXTENDEDDIS ENDOF
  1048.     ." ???"
  1049.    ENDCASE
  1050.     $10 AND IF ."  []" THEN
  1051.   THEN
  1052.   ;
  1053. : 1ROW \ Disassemble instructions on row 1.
  1054.   CASE INSTR @
  1055.   $16 OF LONGRELDIS ENDOF
  1056.   $17 OF LONGRELDIS ENDOF
  1057.   $1A OF BINDIS ENDOF
  1058.   $1C OF BINDIS ENDOF
  1059.   $1E OF EXGTFRDIS ENDOF
  1060.   $1F OF EXGTFRDIS ENDOF  
  1061.   ENDCASE ;
  1062. : 3ROW \ Disassemble instructions on row 3.
  1063.   INSTR @ $34 < IF PBDIS
  1064.   ELSE INSTR @ $38 < IF PSHPULDIS
  1065.   ELSE INSTR @ $3C = IF BINDIS THEN
  1066.   THEN THEN ;
  1067.  
  1068. CREATE DISROWS ' DIRECTDIS , ' 1ROW , ' RELDIS , ' 3ROW ,
  1069.                ' NOOP ,      ' NOOP , ' PBDIS  , ' EXTENDEDDIS ,
  1070.                ' IMMDIS ,    ' DIRECTDIS , ' PBDIS , ' EXTENDEDDIS ,
  1071.                ' IMMDIS ,    ' DIRECTDIS , ' PBDIS , ' EXTENDEDDIS ,
  1072.  
  1073. : 10DIS ( n ---) \ Disassemble instruction with prebyte $10
  1074.   DUP $F0 AND $20 = IF \ Long branch?
  1075.     ." L"  cells INSTRTABLE + @ >NAME count $1f and type space
  1076.              \ Print name of instr.
  1077.     LONGRELDIS
  1078.   ELSE DUP $80 < IF DROP ." SWI2"
  1079.                  ELSE CASE DUP $4F AND
  1080.                         3 OF ." CMPD " ENDOF
  1081.                       $0C OF ." CMPY " ENDOF
  1082.                       $0E OF ." LDY " ENDOF
  1083.                       $0F OF ." STY " ENDOF
  1084.                       $4E OF ." LDS " ENDOF
  1085.                       $4F OF ." STS " ENDOF
  1086.                             ." ??? "
  1087.                       ENDCASE
  1088.                       DUP INSTR !
  1089.                       $F0 AND 4 rshift cells DISROWS + @ EXECUTE
  1090.                  THEN
  1091.   THEN ;
  1092.  
  1093. : 11DIS ( n ---) \ Disassemble instruction with prebyte $11
  1094.   DUP $80 < IF DROP ." SWI3" ELSE
  1095.    CASE DUP $4F AND
  1096.      3 OF ." CMPU " ENDOF
  1097.    $0C OF ." CMPS " ENDOF
  1098.       ." ??? "
  1099.    ENDCASE
  1100.    DUP INSTR !
  1101.    $F0 AND 4 rshift cells DISROWS + @ EXECUTE
  1102.   THEN ;
  1103.  
  1104. : (DIS) \ Disassemble instruction at instruction pointer and advance pointer.
  1105.   IP @ VC@ 1 IP +! DUP
  1106.   $10 = IF DROP IP @ VC@  1 IP +! 10DIS
  1107.         ELSE
  1108.         DUP $11 = IF DROP IP @  VC@  1 IP +! 11DIS
  1109.                   ELSE
  1110.                    DUP INSTR !
  1111.                    DUP cells INSTRTABLE + @ >NAME count $1f and type space 
  1112.                      \ Print name of instr.
  1113.                    4 rshift cells DISROWS + @ EXECUTE \ Treat each row seperately.
  1114.                   THEN
  1115.         THEN ;
  1116.  
  1117. VARIABLE PAGE 0 PAGE !
  1118. : SHOWSTATUS
  1119.   PAGE @ SHOWPAGE
  1120.   ." CC=" CCREG @ BIN. ."  A=$" AREG @ B. ."  B=$" BREG @ B.
  1121.   ."  DP=$" DPREG @ B. ."  X=$" XREG @ H. ." Y=$" YREG @ H.
  1122.   ." U=$" UREG @ H. ." S=$" SREG @ H. CR ."    EFHINZVC PC=$" PCREG @ H.
  1123.   PCREG @ IP ! (DIS) 32 SPACES CR CR 80 SPACES 0 20 AT-XY  ;
  1124.  
  1125. VARIABLE COMMAND \ Command key, just typed.
  1126. VARIABLE NEWPAGE \ Must entire page be shown next?
  1127. : GET# ( ---n) \ Get hexadecimal number from user.
  1128.   BASE @ HEX QUERY BL WORD number? 2DROP
  1129.    SWAP BASE ! NEWPAGE ON ;
  1130.  
  1131. : HEXD \ Process hexadecimal digit from keyboard.
  1132.   COMMAND @ [char] 0 - DUP 9 > IF 7 - THEN \ Convert key to hex.
  1133.   CURSOR @ VC@ 16 * $F0 AND + CURSOR @ VC!
  1134.   CURSOR @ $0F AND 54 +
  1135.   CURSOR @ PAGE @ - $ffff and 4 rshift 1+ AT-XY CURSOR @ VC@ FEMIT ;
  1136. : GO ." Breakpoint: " GET# BPREG ! BREAKPOINT ;
  1137. : STEP \ Set breakpoint after next instruction.
  1138.   SHOWSTATUS IP @ BPREG ! BREAKPOINT newpage on ;
  1139. : SING SINGLE-STEP NEWPAGE ON ;
  1140. : DOIRQ PCREG @ BPREG ! IRQ PCREG @ BPREG @ -
  1141.   IF BREAKPOINT THEN NEWPAGE ON ;
  1142. : DOFIRQ PCREG @ BPREG ! FIRQ PCREG @ BPREG @ -
  1143.   IF BREAKPOINT THEN NEWPAGE ON ;
  1144. : DONMI PCREG @ BPREG ! NMI BREAKPOINT NEWPAGE ON ;
  1145. : DORESET RESET NEWPAGE ON ;
  1146.  
  1147. : upc dup [char] a [char] z 1+ within if 32 - then ;
  1148. : REG ." Register: " KEY UPC DUP EMIT ."  Value: " GET#
  1149.   SWAP CASE
  1150.    [char] D OF DPREG ENDOF
  1151.    [char] A OF AREG ENDOF
  1152.    [char] B OF BREG ENDOF
  1153.    [char] C OF CCREG ENDOF
  1154.    [char] P OF PCREG ENDOF
  1155.    [char] X OF XREG ENDOF
  1156.    [char] Y OF YREG ENDOF
  1157.    [char] U OF UREG ENDOF
  1158.    [char] S OF SREG ENDOF
  1159.     ---
  1160.   ENDCASE ! ;
  1161. create namebuf 50 allot
  1162. s" edit-text " namebuf 1+ swap cmove
  1163. : PROG \ Make cursor equal to program counter.
  1164.   PCREG @ DUP CURSOR ! $FF00 AND PAGE ! NEWPAGE ON ;
  1165. : LOAD namebuf count swap 10 + swap included NEWPAGE ON CLS ;
  1166. : EDIT namebuf count 10 + evaluate NEWPAGE ON CLS ;
  1167. : NAME ." Filename: " namebuf 11 + 39 accept namebuf c! ;
  1168. : INST \ Move cursor to next instruction but do not execute.
  1169.   IP @ PCREG ! PROG ;
  1170. : LOADM \ Load 6809 memory from disk.
  1171.   ." Start address: " GET#
  1172.   ." Filename: " QUERY VLOAD NEWPAGE ON ;
  1173. : WRITEM \ Write 6809 memory to disk.
  1174.   ." Start address: " GET# ." Length: " GET#
  1175.   ." Filename: " QUERY VSAVE NEWPAGE ON ;
  1176. : CURS \ Make program counter equal to cursor location.
  1177.   CURSOR @ PCREG ! NEWPAGE ON ;
  1178. : HELP CLS
  1179.      ." Cursor keys, Home, End, PgUp, PgDn: Move cursor in memory."
  1180.   CR ." ^S ^D ^E ^X: Cursor left/right/up/down."
  1181.   CR ." ^A ^F ^R ^C: Home, End, PgUp, PgDn."
  1182.   CR ." Space     : Move cursor to next location."
  1183.   CR ." 0-9,A-F   : Change memory location at cursor position."
  1184.   CR ." ?         : Help."
  1185.   CR ." G         : Execute until breakpoint."
  1186.   CR ." H         : Reset processor."
  1187.   CR ." I         : Perform IRQ interrupt."
  1188.   CR ." J         : Perform FIRQ interrupt."
  1189.   CR ." K         : Perform NMI interrupt."
  1190.   CR ." L         : Load memory from disk."
  1191.   CR ." N         : Select Assembler file."
  1192.   CR ." P         : Set cursor to program counter."
  1193.   CR ." Q         : Quit."
  1194.   CR ." R         : Change register."
  1195.   CR ." S         : Execute with breakpoint after next instruction."
  1196.   CR ." T         : Single step."
  1197.   CR ." U         : Set program counter after next instruction."
  1198.   CR ." W         : Write memory to disk."
  1199.   CR ." X         : Set program counter to cursor location."
  1200.   CR ." Y         : Assemble the assembler file."
  1201.   CR ." Z         : Edit the assembler file." KEY DROP CLS NEWPAGE ON ;
  1202. : HOME CURSOR @ $FFF0 AND CURSOR ! ;
  1203. : END CURSOR @  $0F OR CURSOR ! ;
  1204. : PGDN $100 CURSOR +! $100 PAGE +! NEWPAGE ON ;
  1205. : PGUP $-100 CURSOR +! $-100 PAGE +! NEWPAGE ON ;
  1206. : ?PD \ Check if page must go down.
  1207.   CURSOR @  PAGE @ 255 + - $ffff and 16signed 0> IF $10 PAGE +! NEWPAGE ON THEN ;
  1208. : ?PU \ Check if page must go up.
  1209.   CURSOR @  PAGE @ - $ffff and 16signed 0< IF $-10 PAGE +! NEWPAGE ON THEN ;
  1210.  
  1211. : DOWN $10 CURSOR +! ?PD ;
  1212. : UP   $-10 CURSOR +! ?PU ;
  1213. : RIGHT 1 CURSOR +! ?PD ;
  1214. : LEFT -1 CURSOR +! ?PU ;
  1215. : CURCOORDS ( --- x y ) \ Coordinates of cursor.
  1216.   CURSOR @ $0F AND 3 * 6 +
  1217.   CURSOR @ PAGE @ - $ffff and 4 rshift 1+ ;
  1218. : CUROFF
  1219.   CURCOORDS AT-XY CURSOR @ VC@ B. 0 20 AT-XY ;
  1220. : CURON
  1221.   CURCOORDS AT-XY REVERSE CURSOR @ VC@ B. -REVERSE 0 20 AT-XY ;
  1222. CREATE KEYTABLE ' HEXD , ' HEXD , ' HEXD , ' HEXD , ' HEXD ,
  1223.                 ' HEXD , ' HEXD , ' HEXD , ' HEXD , ' HEXD ,
  1224.                 ' NOOP , ' NOOP , ' NOOP , ' NOOP , ' NOOP ,
  1225.                 ' HELP , ' NOOP , ' HEXD , ' HEXD , ' HEXD ,
  1226.                 ' HEXD , ' HEXD , ' HEXD , ' GO   , ' DORESET ,
  1227.                 ' DOIRQ , ' DOFIRQ , ' DONMI , ' LOADM , ' NOOP ,
  1228.                 ' NAME , ' NOOP , ' PROG , ' QUIT , ' REG  ,
  1229.                 ' STEP , ' SING , ' INST , ' NOOP , ' WRITEM ,
  1230.                 ' CURS , ' LOAD , ' EDIT ,
  1231. create curstable ' left , ' right , ' up , ' down ,
  1232.                  ' home , ' end , ' pgdn , ' pgup ,
  1233. create ctrltable ' noop  , ' home , ' noop , ' pgdn , ' right , ' up , 
  1234.                  ' end , ' noop ,
  1235.                  ' noop , ' noop , ' noop , ' noop , ' noop , ' noop , ' noop ,
  1236.                  ' noop , ' noop , ' noop , ' pgup , ' left , ' noop , ' noop ,
  1237.                  ' noop , ' noop , ' down ,
  1238.  
  1239.  
  1240. PREVIOUS FORTH DEFINITIONS
  1241.  
  1242. : SIMULATE \ The word that starts the simulator.
  1243.   [ 6809SIM ]
  1244.   CLS NEWPAGE ON FLAG OFF
  1245.   BEGIN
  1246.    eKEY? 0= NEWPAGE @ AND IF SHOWSTATUS NEWPAGE OFF THEN
  1247.    eKEY upc
  1248.    CUROFF DUP COMMAND ! 
  1249.    dup 25 < if 
  1250.     cells ctrltable + @ execute 
  1251.    else
  1252.    [char] 0 - DUP 44 U<
  1253.    IF cells KEYTABLE + @ EXECUTE
  1254.    ELSE 48 + k-left - DUP 8 U<
  1255.         IF cells CURSTABLE + @ EXECUTE
  1256.         ELSE BL k-left - = IF RIGHT THEN
  1257.         THEN
  1258.    THEN
  1259.    THEN
  1260.    cursor @ $ffff and cursor !
  1261.    page @ $ffff and page !
  1262.    CURON
  1263.   0 until ;
  1264.  
  1265.  
  1266.  
  1267. : DISAS ( addr1 addr2 ---)
  1268.   [ 6809SIM ]
  1269.   SWAP IP !
  1270.   BEGIN
  1271.    CR
  1272.    IP @
  1273.    (DIS)
  1274.    20 ?XY drop - SPACES SPACE
  1275.    [char] \ EMIT SPACE DUP H. IP @ SWAP DO I VC@ B. SPACE LOOP
  1276.    IP @ OVER U> UNTIL
  1277.    DROP ;
  1278.  
  1279. FORTH
  1280.  
  1281. 6809sim definitions \ Add IO capability to 6809 simulator.
  1282.   \ Leave out if SWI2,SWi3 and SYNC must retain original functions.
  1283. : SWI
  1284.   FLAG @ CASE
  1285.    0 OF SWI ENDOF
  1286.    1 OF BREG @ EMIT ENDOF
  1287.    2 OF KEY? IF CLC KEY BREG ! 
  1288.                        ELSE SEC THEN
  1289.      ENDOF
  1290.    ENDCASE
  1291. ;
  1292. ' SWI INSTRTABLE $3F cells + ! \ Modify SWI instruction such that SWI2 means
  1293.  
  1294. : SYNC 7 emit quit ;
  1295.  
  1296. ' SYNC INSTRTABLE $13 cells + ! 
  1297.  
  1298.                             \ EMIT and SWI3 means KEY.
  1299. forth definitions
  1300.